C----------------------------------------------------------------------------

C  Module name: traversal state list module.

C  Author: Gareth Williams.

C  Function: This module contains functions for inquiring information
C            from the PHIGS Traversal State List.

C  Dependencies: 

C  Internal function list: traversestruct, box

C  External function list: ptk_boundingbox

C  Hashtables used: none.

C  Modification history: (Version), (Date), (name), (Description).

C  1.0, 4th September 1991, G. Williams, First version.

C----------------------------------------------------------------------------

       SUBROUTINE ptkf_stacktsl()
C /*
C ** \blurb{This function puts the current TSL value on the TSL stack.}
C */
       external ptk_stacktsl !$PRAGMA C(ptk_stacktsl)

       call ptk_stacktsl()

       RETURN
       END

       SUBROUTINE ptkf_unstacktsl()
C /*
C ** \blurb{This function gets the topmost TSL value from the TSL stack.}
C */  
       external ptk_unstacktsl !$PRAGMA C(ptk_unstacktsl)

       call ptk_unstacktsl()

       RETURN
       END

       LOGICAL FUNCTION ptkf_boundingbox(structid, wcbounds, descend)
C /*
C ** \parambegin
C ** \param{INTEGER}{structid}{structure network identifier}{IN}
C ** \param{REAL}{wcbounds(6)}{bounding box in world coordinates}{OUT}
C ** \param{LOGICAL}{descend}{flag to indicate traversal}{IN}
C ** \paramend
C ** \blurb{This function evaluates the bounding box for a structure or
C ** structure network. If {\tt descend} 
C ** is set to TRUE then the bounding box for the complete structure
C ** network is returned, otherwise just for a single structure.
C ** The function returns TRUE if the resulting bounding box is valid, 
C ** otherwise FALSE. A structure with no output primitives returns an
C ** invalid bounding box.}
C */
       INTEGER structid
       REAL wcbounds(6)
       LOGICAL descend
       LOGICAL*1 ptk_boundingbox, ans, desc
       external ptk_boundingbox !$PRAGMA C(ptk_boundingbox)

       desc = descend
       ans = ptk_boundingbox(%val(structid), wcbounds, 
& %val(desc))
       if (ans .eq. 1) then
          ptkf_boundingbox = .TRUE.
       else
          ptkf_boundingbox = .FALSE.
       endif

       RETURN
       END

       SUBROUTINE ptkf_inittsl()
C /*
C ** \blurb{This function initialises the current TSL values to the
C ** default values from the PHIGS description table.
C ** The default ASF value for each attribute is assumed to be INDIVIDUAL.}
C */
       external ptk_inittsl !$PRAGMA C(ptk_inittsl)

       call ptk_inittsl()

       RETURN
       END

      SUBROUTINE ptkf_tsltraverserange(startstid, startelemid, 
& stopstid, stopelemid, descend)
C /*
C ** \parambegin
C ** \param{INTEGER}{startstid}{start structure identifier}{IN}
C ** \param{INTEGER}{startelemid}{start element number}{IN}
C ** \param{INTEGER}{stopstid}{stop structure identifier}{IN}
C ** \param{INTEGER}{stopelemid}{stop element number}{IN}
C ** \param{LOGICAL}{descend}{flag to indicate traversal}{IN}
C ** \paramend
C ** \blurb{This function makes TSL traverse between two points in a structure
C ** network. If {\tt descend} is set to TRUE then any
C ** EXECUTE STRUCTURE elements which occur between the two points
C ** are followed, otherwise they are ignored.}
C */
      INTEGER startstid, startelemid, stopstid, stopelemid
      LOGICAL descend
      LOGICAL*1 desc
      external ptk_tsltraverserange !$PRAGMA C(ptk_tsltraverserange)

      desc = descend
      call ptk_tsltraverserange(%val(startstid), %val(startelemid), 
& %val(stopstid), %val(stopelemid), %val(desc))

      RETURN
      END

      SUBROUTINE ptkf_inqboundingbox(bbox)
C /*
C ** \parambegin
C ** \param{REAL}{bbox(6)}{bounding box}{OUT}
C ** \paramend
C ** \blurb{This function may be used to obtain the current TSL bounding box
C ** value. This is the bounding box of the TSL structure network at the
C ** current point of traversal.}
C */
      REAL bbox(6)
      external ptk_inqboundingbox !$PRAGMA C(ptk_inqboundingbox)

      call ptk_inqboundingbox(bbox)

      RETURN
      END

       SUBROUTINE ptkf_inqtsledge(edgeind, edgeflag, edgetype, 
& edgewidth, edgecolour)
C /*
C ** \parambegin
C ** \param{INTEGER}{edgeind}{edge index}{OUT}
C ** \param{INTEGER}{edgeflag}{edge flag}{OUT}
C ** \param{INTEGER}{edgetype}{edge type}{OUT}
C ** \param{REAL}{edgewidth}{edge width}{OUT}
C ** \param{INTEGER}{edgecolour}{edge colour}{OUT}
C ** \paramend
C ** \blurb{This function may be used to obtain the current TSL 
C ** edge attributes.}
C */
       INTEGER edgeind, edgeflag, edgetype
       REAL edgewidth
       INTEGER edgecolour
       external ptk_inqtsledge !$PRAGMA C(ptk_inqtsledge)

       call ptk_inqtsledge(edgeind, edgeflag, edgetype, edgewidth, 
& edgecolour)

       RETURN
       END

       SUBROUTINE ptkf_inqtslline(lineind, linetype, linewidth, 
& linecolour)
C /*
C ** \parambegin
C ** \param{INTEGER}{lineind}{line index}{OUT}
C ** \param{INTEGER}{linetype}{line type}{OUT}
C ** \param{REAL}{linewidth}{line width}{OUT}
C ** \param{INTEGER}{linecolour}{line colour}{OUT}
C ** \paramend
C ** \blurb{This function may be used to obtain the current TSL line 
C ** attributes.}
C */
       INTEGER lineind, linetype
       REAL linewidth
       INTEGER linecolour
       external ptk_inqtslline !$PRAGMA C(ptk_inqtslline)

       call ptk_inqtslline(lineind, linetype, linewidth, linecolour)

       RETURN
       END

       SUBROUTINE ptkf_inqtslmarker(markerind, markertype, 
& markersize, markercolour)
C /*
C ** \parambegin
C ** \param{INTEGER}{markerind}{marker index}{OUT}
C ** \param{INTEGER}{markertype}{marker type}{OUT}
C ** \param{REAL}{markersize}{marker size}{OUT}
C ** \param{INTEGER}{markercolour}{marker colour}{OUT}
C ** \paramend
C ** \blurb{This function may be used to obtain the current TSL marker 
C ** attributes.}
C */
       INTEGER markerind, markertype
       REAL markersize
       INTEGER markercolour
       external ptk_inqtslmarker !$PRAGMA C(ptk_inqtslmarker)

       call ptk_inqtslmarker(markerind, markertype, markersize, 
& markercolour)

       RETURN
       END

       SUBROUTINE ptkf_inqtslinterior(intind, intstyle, intstyleind, 
& intcolour)
C /*
C ** \parambegin
C ** \param{INTEGER}{intind}{interior index}{OUT}
C ** \param{INTEGER}{intstyle}{interior style}{OUT}
C ** \param{REAL}{intstyleind}{interior style index}{OUT}
C ** \param{INTEGER}{intcolour}{interior colour}{OUT}
C ** \paramend
C ** \blurb{This function may be used to obtain the current TSL interior 
C ** attributes.}
C */
       INTEGER intind, intstyle, intstyleind, intcolour
       external ptk_inqtslinterior !$PRAGMA C(ptk_inqtslinterior)

       call ptk_inqtslinterior(intind, intstyle, intstyleind, intcolour)

       RETURN
       END

       SUBROUTINE ptkf_inqtsltext(textind, textfont, textprec, 
& textpath, textalign, textcolour)
C /*
C ** \parambegin
C ** \param{INTEGER}{textind}{text index}{OUT}
C ** \param{INTEGER}{textfont}{text font}{OUT}
C ** \param{INTEGER}{textprec}{text precision}{OUT}
C ** \param{INTEGER}{textpath}{text path}{OUT}
C ** \param{INTEGER}{textalign}{text alignment}{OUT}
C ** \param{INTEGER}{textcolour}{text colour}{OUT}
C ** \paramend
C ** \blurb{This function may be used to obtain the current TSL text 
C ** attributes.}
C */
       INTEGER textind, textfont, textprec, textpath
       INTEGER textalign, textcolour
       external ptk_inqtsltext !$PRAGMA C(ptk_inqtsltext)

       call ptk_inqtsltext(textind, textfont, textprec, textpath, 
& textalign, textcolour)

       RETURN
       END

       SUBROUTINE ptkf_inqtslannotext(style, charheight, charup,
& textalign, textpath)
C /*
C ** \parambegin
C ** \param{INTEGER}{style}{annotation style}{OUT}
C ** \param{REAL}{charheight}{annotation character height}{OUT}
C ** \param{REAL}{charup(2)}{annotation character up vector}{OUT}
C ** \param{INTEGER}{textalign}{annotation text alignment}{OUT}
C ** \param{INTEGER}{textpath}{annotation text path}{OUT}
C ** \paramend
C ** \blurb{This function may be used to obtain the current TSL
C ** annotation text attributes.}
C */
       INTEGER style
       REAL charheight, charup(2)
       INTEGER textalign, textpath
       external ptk_inqtslannotext !$PRAGMA C(ptk_inqtslannotext)

	call ptk_inqtslannotext(style, charheight, charup, textalign, 
& textpath)

       RETURN
       END

       SUBROUTINE ptkf_inqtslchar(exp, spacing, height, charup)
C /*
C ** \parambegin
C ** \param{REAL}{exp}{character expansion factor}{OUT}
C ** \param{REAL}{spacing}{character spacing}{OUT}
C ** \param{REAL}{height}{character height}{OUT}
C ** \param{REAL}{charup(2)}{character up vector}{OUT}
C ** \paramend
C ** \blurb{This function may be used to obtain the current TSL character 
C ** attributes.}
C */
       REAL exp, spacing, height, charup(2)
       external ptk_inqtslchar !$PRAGMA C(ptk_inqtslchar)

       call ptk_inqtslchar(exp, spacing, height, charup)

       RETURN
       END

       SUBROUTINE ptkf_inqtslctm(globaltran, localtran)
C /*
C ** \parambegin
C ** \param{REAL}{globaltran(4, 4)}{global transformation matrix}{OUT}
C ** \param{REAL}{localtran(4, 4)}{local transformation matrix}{OUT}
C ** \paramend
C ** \blurb{This function may be used to obtain the current TSL 
C ** transformation matrices.}
C */
       REAL globaltran(4, 4), localtran(4, 4)
       external ptk_inqtslctm !$PRAGMA C(ptk_inqtslctm)

       call ptk_inqtslctm(globaltran, localtran)

       RETURN
       END

       SUBROUTINE ptkf_inqtslnameset(num, nameset, totalnum)
C /*
C ** \parambegin
C ** \param{INTEGER}{size}{length of nameset integer list}{IN}
C ** \param{INTEGER}{nameset(*)}{current nameset}{OUT}
C ** \param{INTEGER}{totalsize}{actual length of nameset integer list}{OUT}
C ** \paramend
C ** \blurb{This function may be used to obtain the current TSL nameset.}
C */
       INTEGER num, nameset(num), totalnum
       external ptkc_inqtslnameset !$PRAGMA C(ptkc_inqtslnameset)

       call ptkc_inqtslnameset(%val(num), nameset, totalnum)

       RETURN
       END

       SUBROUTINE ptkf_inqtslids(pickid, hlhsrid, viewind)
C /*
C ** \parambegin
C ** \param{INTEGER}{pickid}{pick identifier}{OUT}
C ** \param{INTEGER}{hlhsrid}{HLHSR identifier}{OUT}
C ** \param{INTEGER}{viewind}{view index}{OUT}
C ** \paramend
C ** \blurb{This function may be used to obtain the current TSL values
C ** for pick identifier, HLHSR identifier and view index.}
C */
       INTEGER pickid, hlhsrid, viewind
       external ptk_inqtslids !$PRAGMA C(ptk_inqtslids)

       call ptk_inqtslids(pickid, hlhsrid, viewind)

       RETURN
       END

       SUBROUTINE ptkf_inqtslpattern(size, refpt, refvec)
C /*
C ** \parambegin
C ** \param{REAL}{size(2)}{pattern size}{OUT}
C ** \param{REAL}{refpt(3)}{pattern reference point}{OUT}
C ** \param{REAL}{refvec(3, 2)}{pattern reference vectors}{OUT}
C ** \paramend
C ** \blurb{This function may be used to obtain the current TSL pattern 
C ** attributes.}
C */
       REAL size(2), refpt(3), refvec(3, 2)
       external ptk_inqtslpattern !$PRAGMA C(ptk_inqtslpattern)

       call ptk_inqtslpattern(size, refpt, refvec)

       RETURN
       END

       SUBROUTINE ptkf_inqtslattrasf(attr, asf)
C /*
C ** \parambegin
C ** \param{INTEGER}{attr}{attribute type}{IN}
C ** \param{INTEGER}{asf}{attribute aspect source flag}{OUT}
C ** \paramend
C ** \blurb{This function may be used to obtain the current TSL 
C ** aspect source flag value for attribute type {\tt attr}.}
C */
       INTEGER attr, asf
       external ptk_inqtslattrasf !$PRAGMA C(ptk_inqtslattrasf)

       call ptk_inqtslattrasf(%val(attr), asf)

       RETURN
       END

C end of tsl.f
